perm filename TREST.F4[MSS,LCS]6 blob
sn#130122 filedate 1974-11-12 generic text, type T, neo UTF8
00100 C******* SUBRS TAIL, FERMTA, REST, RDDATA, BREP, EXCH, SORT2, NOZERO, ALPHA
00200 SUBROUTINE TAIL(RJX,RA,RMINI)
00300 COMMON /STF/RSTFAC(8),RSTJC
00400 COMMON /PLTR/IPLT,RHT,DIS
00500 DIMENSION ITAIL(16)
00600 DATA ITAIL/16,100090007,110012,120016,200120016,120019,100026,
00700 1 80030,20036, 40, 33, 30031, 50029,80025,100022,120016/
00800 Q=-1.
00900 IF(RA)Q=1.
00910 ITAIL(1)=10
00955 IF(IPLT)ITAIL(1)=16
01000 CALL CENTER(RJY)
01100 CALL JDRAW(ITAIL,RJX,RJY,RMINI,1.,Q)
01200 1 IF(IPLT.GE.0)RETURN
01300 IF(RMINI.NE.RSTJC)Q=Q*.6
01400 CC CALL OLDFIL(ITAIL(10),RJX,RJY,ABS(Q),Q)
01500 CALL FILLMS(12,ITAIL(5),RJX,RJY,ABS(Q),Q)
01600 C RA=-,STEM UP; RA=+, STEM DOWN.
01700 END
01800
01900 SUBROUTINE REST
02000 COMMON /STF/RSTFAC(8),RSTJC/PLTR/IPLT,RHT,DIS
02100 COMMON RJB,JA,CENTR,JB,RJQ(20),JQ(20)
02200 EQUIVALENCE(JE,JQ(3))
02300 DIMENSION LRST(3),IRST(47),MR(2),MF(2)
02400 DATA IRST/9,100000033,160033,160030, 30,32 ,160032 ,160031,
02600 1 31, 23,100000051,100038,32,110017,200050044, 32 ,50026,
02700 1 100038,50044,100110017,70018,50017,50015,60011, 10016,
02800 1 18, 20,10022,30023, 50023, 70022,110017,
02900 1 15,100030033, 40032, 80032,120035,150039,70014,200010037,
03000 1 30039, 50039, 70037, 70035, 50033, 30033,10035/
03100 1,LRST/1,10,33/,MR/18,8/,MF/15,40/
03150 C LRST = BEGINNING OF EACH REST, MR=FILLER WDCNT, MF=FILL START.
03200
03300 CC IF(LRST(1).EQ.0)CALL RDDATA('REST',LRST,IRST)
03400 L=JE
03500 IF(L.GT.1)L=1
03600 IF(L)L=-1
03700 C L>3 WHEN SEVERAL TAILS ON REST
03800 CALL CENTER(CENTR)
03900 IF(JE.EQ.-2)CENTR=CENTR+9.4*RSTJC
04000 CALL JDRAW(IRST(LRST(L+2)),RJB,CENTR,RSTJC,1.,1.)
04100 IF(JE.OR.IPLT.GE.0)RETURN
04200 L=L+1
04300 CALL FILLMS(MR(L),IRST(MF(L)),RJB,CENTR,1.,1.)
04400 C WHY GO THROUGH NOTWRT??
04500 END
04600
04700 CC SUBROUTINE RDDATA(NM,JARY,IARY)
04800 C READS DATA
04900 CC DIMENSION JARY(1),IARY(1)
05000 CC REWIND 23
05100 CC CALL IFILE(23,NM)
05200 CC READ(23,5)K,(JARY(K),K=1,10)
05300 CC N=1
05400 CC1 READ(23,5,END=2)K,L,(IARY(K),K=N,N+L-1)
05500 CC N=N+L
05600 CC GO TO 1
05700 CC2 RETURN
05800 CC5 FORMAT(12I)
05900 CC END
06000
06100 C FOR SINGLE (OR DOUBLE) BAR REPEAT SIGN
06200 SUBROUTINE BREP(RJB,RSTJC)
06300 DIMENSION IREP(35)
06400 DATA IREP/35,100000015,280043,290043, 10015, 20015, 300043,310043
06500 1,30015, 40015, 320043,100020037, 30038, 40038, 50037
06600 1,50036, 40035, 30035, 20036, 20037, 50037, 20036, 40036
06700 1,100270022,280021,290021,300022,300023,290024,280024,270023
06800 1,270022, 300022, 270023, 290023/
06900 CC IF(JREP(1).EQ.0)CALL RDDATA('BREP',JREP,IREP)
07000 CALL CENTER(R)
07100 CALL JDRAW(IREP,RJB,R,RSTJC,1.,1.)
07200 END
07300
07400 SUBROUTINE FERMTA(RINV)
07500 COMMON RJB,JA,CENTR,JB,RJQ(20),JQ(20)
07600 COMMON /PLTR/IPLT,RHT,DIS
07700 COMMON /STF/RSTFAC(8),RSTJC
07800 DIMENSION JFERM(24)
07900 DATA JFERM/24,310020003,10010010,20015,60017,110017,160015,
08000 1 190010,200003,170010,150012,120014,70014,30012,10010,
08100 1 10020003,100070007,80008,100008,110007,110006,100005,80005
08200 1 ,70006/
08300 CC IF(JFERM(1).EQ.0)CALL RDDATA('FERM',JFERM,IFERM)
08400 CC R=INV
08500 CALL JDRAW(JFERM,RJB,CENTR,RSTJC,1.,RINV)
08600 CC IF(IPLT)CALL OLDFIL(IFERM(IFERM(1)+2),RJB,CENTR,1.,RINV)
08700 IF(IPLT)CALL FILLMS(JFERM(1),JFERM(2),RJB,CENTR,1.,RINV)
08800 END
08900
09000 SUBROUTINE EXCH(X,Y)
09100 Z=X
09200 X=Y
09300 Y=Z
09400 END
09500 SUBROUTINE SORT2(RPOS,M)
09600 DIMENSION RPOS(2,200)
09700 L=2
09800 3 J=-1
09900 RX=RPOS(1,L-1)
10000 DO 2 K=L,M
10100 IF(RPOS(1,K).GE.RX)GO TO 2
10200 RX=RPOS(1,K)
10300 C WHY WERE ALL THE RX'S JX ????? 9/6/73
10400 J=K
10500 2 CONTINUE
10600 IF(J)GO TO 4
10700 K=L-1
10800 CALL EXCH(RPOS(1,K),RPOS(1,J))
10900 CALL EXCH(RPOS(2,K),RPOS(2,J))
11000 4 L=L+1
11100 IF(L.LE.M)GO TO 3
11200 END
11300
11400 SUBROUTINE NOZERO(X)
11500 IF(X.EQ.0)X=1
11600 END
00100 C****** FOR LISTS OF LETTERS, ETC. AND TRILL *******
00200 SUBROUTINE ALPHA
00300 COMMON /PLTR/IPLT,RHT,DIS /FONT/JFONT
00400 COMMON RJB,JA,CENTR,JB,RJQ(20),JQ(20)
00500 EQUIVALENCE(JC,JQ(1)),(JD,JQ(2)),(JE,JQ(3)),(RJE,RJQ(3)),
00600 1(RJH,RJQ(6)),(NRJ,RJQ(8)),(JY,JQ(10)),(JX,JQ(11)),(RSX,JQ(12)),
00700 1(RJF,RJQ(4)),(JG,JQ(5)),(JH,JQ(6)),(JI,JQ(7)),(JJ,JQ(8))
00800 1,(JK,JQ(9)),(JF,JQ(4)),(RJG,RJQ(5)),(RJD,RJQ(2)),(IFNT,JQ(13)),
00810 1(NR,JQ(14)),(RSP,JQ(15)),(RY,JQ(16)),(RX,JQ(17)),(RZ,JQ(18)),(RW
00820 1,JQ(19)),(RB,JQ(20)),(R,RJQ(20)),(FILL,RJQ(19))
00825 1,(JTR,RJQ(17)),(RF,RJQ(15)),(JBX,RJQ(14))
00830 CC 1,(JTR,RJQ(17)),(RTR,RJQ(16)),(RF,RJQ(15)),(JBX,RJQ(14))
00900 COMMON/STF/RSTFAC(8),RSTJC
01000 DATA R4/-2.1/
01100
01200 IF(JA.EQ.20)GO TO 20
01210 JTR=99
01400 C PRIMITIVE IS DEFAULT FONT. #=SET BACK TO PRIM.
01500 C ONLY 11 LETTERS WITHOUT FONT RESET.
01700 54 R=19.7*RJE*RSTJC
01800 RB=JB
01900 JI=0
02000 C JI=0 AVOIDS ROTATION IN 'CLEFS'
02300 DO 50 KA=4,6
02400 JY=RJQ(KA)*100.+.2
02500 JX=1000000
02600 DO 53 LA=1,4
02700 JF=JY/JX
02705 IF(JF.EQ.99)GO TO 55
02707 C NO MORE IN THIS WD.
02710 IF(JF.LT.50)GO TO 1
02800 GO TO(2,3,1,4,5),JF-49
02900 C SWITCHES FOR DIFF. FONTS.
03000 2 NR='BDR40'
03100 C &=NON-ITALICS -- JFONT IS TEMPORARY SWITCH 5/74
03150 GO TO 8
03200 3 NR='BDI40'
03300 C @=51=ITALICS
03350 8 IF(IFNT.EQ.0)IFNT=-1
03400 GO TO 11
03500 4 FILL=-2
03600 GO TO 11
03700 5 FILL=0
03800 GO TO 11
03900 1 CALL SPACER(JF,IFNT,RB,R)
03950 IF(JF-47)7,6,11
07300 7 IF(JFONT.EQ.0.AND.IPLT.GE.0)GO TO 30
07400 C JFONT=0 FOR FIXED WIDTH OF FONTS. = AND ONLY DPYS PRIMITIVE.
07600 JE=JF
07610 IF(IFNT.EQ.0)GO TO 30
07650 IF(JF.GE.36)GO TO 30
07675 C PUNCTUATION AND SPACE.
07700 IF(IFNT.AND.JE.GT.9)JE=JE+26
07800 RX=RJF
07900 RJF=RJE*.28
08000 C .29 IS SIZE FACTOR -- PERHAPS CHANGE SIZE IN FONT TO =1.
08100 RY=RJG
08200 RJG=RJF
08300 RZ=RJH
08400 RW=RJD
08500 RJD=RJD+R4
08550 C SHIFTS DOWN ??? WHY NOT GET RID OF THIS.??
08600 RJH=FILL
08700 NRJ=NR
08800 C GETS RIGHT FILE
08900 JA=11
09000 CC*** CALL NOTWRT
09025 RJB=JB
09050 CALL CLEFS
09100 RJF=RX
09200 RJG=RY
09300 RJH=RZ
09400 RJD=RW
09500 C PUTS BACK RIGHT STUFF
09700 GO TO 6
09800
09900 30 JA=5
09950 JG=0
10000 CALL NOTWRT
10100 C 47=BLANK (WAS 99)
10500 6 JB=ROFF(RB)
11000 11 JY=JY-JF*JX
11100 CC??? RSX=RS
11200 53 JX=JX/100
11300 50 CONTINUE
11310 55 IF(JTR.EQ.99)RETURN
11400 GO TO 52
11500
11550
11600 C FOR TRILLS
11700 CC20 RTR=RJB
11800 C RTR SAVES RJB(WHICH GETS CLOBBERED WHEN 'TR' IS WRITTEN.)
11900 C 20, POS1, STF, NT#, SIZE, POS2, X IF X=1 THEN NO WAVEY LINE
11910 20 CALL NOZERO(RJE)
11955 RJJ=RJE
12000 RJE=.8*RJE
12100 RF=RJF
12200 JBX=JB
12300 RJF=495129.27
12400 C %@tr LWR CASE, ITAL. TR
12500 RJG=999999.99
12600 RJH=RJG
12700 JTR=JG
12800 GO TO 54
13000 52 IF(JTR.NE.0)RETURN
13200 C RETURN IF NO WAVY LINE IS NEEDED
13210 JB=JBX+22.*RSTJC*RJJ
13300 JA=4
13400 CC RJB=RTR+4.*RSTJC
13500 JG=-2
13600 C JG IS SWITCH TO DRAW WIGGLE
13650 RJF=RF
13700 RJE=RJD+.7*RJJ
13710 RJH=.9*RJJ
13735 C RJJ IS SIZE (P5)
13760 IF(IPLT)JJ=1
13800 CALL ITMSUB
13860 C SINGLE WIGGLE ON DPY, DOUBLE ON PLOTTER.
13900 END
14000
14100
14200 SUBROUTINE SPACER(JF,IFNT,RB,R)
14300 C SPACES ALPHABET ITEMS.
14400 DATA RS/1.08/,RSPC/1./,RLWR/.96/
15000 CC IF(JF.EQ.47.OR.JF.GT.90)GO TO 2
15100 CC IF(JF.LT.47.AND.IFNT.EQ.0)GO TO 3
15200 C JUMP TO USE PRIMITIVE ALPHABET.
15300 IF((JF.GT.9.AND.JF.LT.36).OR.JF.GT.47)GO TO 10
15400 C NEXT FOR NUMBERS, SPACE AND PUNCTUATION.
15500 RSX=RSPC
15600 GO TO 3
15700 10 IF(JF.LT.47)GO TO 5
15800 IF(JF.EQ.52)GO TO 14
15900 IF(JF.EQ.48)IFNT=1
16000 IF(JF.EQ.49)IFNT=-1
16100 RETURN
16200 14 IFNT=0
16300 C #=52=PRIMITIVE
16400 JA=5
16500 CCC RSX=1.
16600 RETURN
17000 5 RSX=RS
17200 IF(IFNT)RSX=RLWR
17250 C FOR LOWER CASE SPACING. (96%)
17400 IF(JF.EQ.22.OR.JF.EQ.32)RSX=RSX*1.12
17500 C FOR M AND W
17700 3 IF(JF.EQ.1.OR.JF.EQ.18.OR.JF.EQ.19.OR.JF.GE.36)GO TO 21
17705 C FOR 1,I AND J
17710 IF(IFNT.GE.0)GO TO 4
17720 C NEXT FOR LOWER CASE ONLY.
17730 IF(JF.NE.15.AND.JF.NE.19.AND.JF.NE.21.AND.JF.NE.29)GO TO 4
17735 21 IF(JF.NE.47)RSX=RSX*.68
17750 C FOR F,I,J,L,T
17800 4 RB=RB+R*RSX
17900 END